The 640 MEG Shareware Studio 2/The 640 Meg Shareware Studio CD-ROM Volume II (Data Express)(1993).ISO/pascal/mrgsort.zip/TXTFILES.PAS

Pascal/Delphi Source File | 1989-04-23 | 23KB | 673 lines

{$IFDEF ver50}
{$A-,B-,D-,E+,F-,I+,L-,N-,O-,R-,S+,V+}  (* MUST REMOVE FOR TP4 *)
{$ELSE}
{$R-,S-,I+,D-,T+,F-,V+,B-,N-,L+ }
{$ENDIF}

UNIT txtfiles;
(* Kluges to replace missing STANDARD constructs in Turbo  *)
(* Unfortunately these routines cannot be overloaded, as   *)
(* are the standard procedures, and must also be referred  *)
(* to by new (but similar) names.  A proper system imple-  *)
(* mentation would avoid these nuisances.                  *)

(* With this module in place text input can be programmed  *)
(* with STANDARD Pascal semantics.  The resultant source   *)
(* is then portable to any ISO standard system with a      *)
(* minimum of fuss.  It is bad enough to have to alter std *)
(* procedure names, but absolutely impossible to have to   *)
(* rethink the entire i/o process.                         *)

(* Note that "exists" and "readx" are inserted underneath  *)
(* the standard implementations of "reset" and "read".     *)
(* These extensions are not normally available in ISO std. *)

(* 1.20 Added filename, page, prompt, overprint.           *)
(* 1.10 Added stdin, stdout, stderr, blockdev to report    *)
(*      on any redirection imposed or general destination  *)

(* Copyright (c) 1988 by C.B. Falconer,                    *)
(*                       680 Hartford Tpk.,                *)
(*                       Hamden, Ct 06517   [phone] *)
(* All rights reserved.                                    *)

(* This is NOT free software, but SHAREWARE.  If you use   *)
(* this after a suitable test period (1 month suggested)   *)
(* you must register it, for a fee of $20.  This will      *)
(* entitle you to a reasonable amount of telephone advice  *)
(* (on your paid call) and future upgrades and support.    *)
(* I will also supply registered owners with the source so *)
(* that they can recompile for 80x87 processors.           *)

(* The compiled TPU supplied was compiled under Turbo      *)
(* Pascal  4, without using any numeric processor.  Thus   *)
(* it is incompatible with programs using the 80x87.       *)

(* This module functions with Turbo Pascal 4.0.            *)
(* No warranty whatsover is made, and C.B. Falconer will   *)
(* not be liable for any damages or failures.              *)

(* If you use this module with the CRT unit, the EOF char  *)
(* (CTL-Z) will never appear, UNLESS your program does     *)
(*       checkeof := true;     somewhere before using this *)

(* A note on naming:                                       *)
(* All replacement read procedures are either READ???? or  *)
(* READX??? functions.  The read procedures abort the      *)
(* program on invalid input, while the readx functions     *)
(* return TRUE for any error.  The ??? is  INT, WD, LONG   *)
(* or REAL, depending on the input type desired.           *)

INTERFACE

USES dos;

  TYPE
    fntype      = string[80];   (* holds a complete file name *)

  (* 1---------------1 *)

  FUNCTION existxt(VAR f : text) : boolean;
  (* Exists is a standard feature of PascalP.             *)

  (* 1---------------1 *)

  PROCEDURE get(VAR f : text);
  (* since Turbo never supplied it, we can use the original name *)

  (* 1---------------1 *)

  PROCEDURE filename(VAR f : text; VAR fn : fntype);
  (* Highly Turbo specific.  This allows other procedures/functions *)
  (* to extract the filename when passed only the actual file. You  *)
  (* thus do not need to retain a user supplied name elsewhere.     *)
  (* THIS IS NOT A FUNCTION - thus can be ported to Std. Systems.   *)

  (* 1---------------1 *)

  PROCEDURE page(VAR f : text);   (* Missing in Turbo *)

  (* 1---------------1 *)

  PROCEDURE overprint(VAR f : text);
  (* Next line overprints this one.  Use like "writeln"  *)

  (* 1---------------1 *)

  PROCEDURE prompt(VAR f : text);
  (* Forces buffer flushing without eoln.  Null in Turbo. *)
  (* For logical equivalence with output buffered systems *)
  (* If your source uses this whenever prompting the user *)
  (* the code will be portable to other Pascal systems.   *)
  (* e.g "write(Enter your name:); prompt(output);"       *)

  (* 1---------------1 *)

  FUNCTION version(show : boolean) : integer;
  (* returns the version number.  Show causes a console message *)

  (* 1---------------1 *)

  FUNCTION fptr(VAR f : text) : char;
  (* Allows replacing the STANDARD construct f^ by "fptr(f)"    *)
  (* A proper system implementation actually returns a pointer  *)
  (* so that "f^ := char" is possible.  Not allowed here.       *)

  (* 1---------------1 *)

  PROCEDURE skipblks(VAR f : text);
  (* Skips blanks, but NOT eolns until first non-blank char     *)
  (* A tab is considerd a blank.  Must be separated due to the  *)
  (* non-standard Turbo eoln implementation.                    *)

  (* 1---------------1 *)

  PROCEDURE skipwhite(VAR f : text);
  (* skips blanks and eolns until first non-blank char          *)
  (* This hides the lack of f^ = ' ' in Turbo when eoln is true *)

  (* 1---------------1 *)

  FUNCTION readxwd(VAR f : text; VAR w : word) : boolean;
  (* returns true for input error, when fptr(f) is bad char *)
  (* Replacement for standard read(word) with error checks. *)
  (* Unlike Turbo, reading terminates on the 1st non digit, *)
  (* but only after leading blanks have been skipped.       *)
  (* A feature of PascalP for reals/integers/words (readx). *)
  (* Note that, apart from the non-standard Std procedure   *)
  (* nomenclature, this is written entirely in STD Pascal.  *)
  (* On exit fptr(f) will return the terminating character  *)
  (* On overflow input is scanned to a non-numeric char.    *)

  (* 1---------------1 *)

  FUNCTION readxint(VAR f : text; VAR i : integer) : boolean;
  (* returns true for input error, when fptr(f) is bad char *)
  (* Replacement for standard read(integer) with error chks *)
  (* Unlike Turbo, reading terminates on the 1st non digit, *)
  (* but only after leading blanks and (optional) sign have *)
  (* been skipped.  A feature of PascalP for reals/integers *)
  (* Note that, apart from the non-standard Std procedure   *)
  (* nomenclature, this is written entirely in STD Pascal.  *)
  (* On exit fptr(f) will return the terminating character  *)
  (* On overflow input is scanned to a non-numeric char.    *)

  (* 1---------------1 *)

  PROCEDURE readint(VAR f : text; VAR i : integer);
  (* replacement for STANDARD Pascal read(f, integer), which is *)
  (* defined to cause a system error and halt on invalid input. *)
  (* Unlike Turbo, reading terminates on the 1st non digit, but *)
  (* only after leading blanks and (optional) sign have been    *)
  (* skipped. Again, written in STD Pascal.                     *)
  (* On exit fptr(f) will return the terminating character.     *)
  (* On overflow input is scanned to a non-numeric character.   *)

  (* 1---------------1 *)

  PROCEDURE readwd(VAR f : text; VAR w : word);
  (* This does not exist in STANDARD Pascal (only integer), but *)
  (* this is how it would look if it did.  This is defined to   *)
  (* cause a system error and halt on invalid input.            *)
  (* Unlike Turbo, reading terminates on the 1st non digit, but *)
  (* only after leading blanks and (optional) sign have been    *)
  (* skipped. Again, written in STD Pascal.                     *)
  (* On exit fptr(f) will return the terminating character.     *)
  (* On overflow input is scanned to a non-numeric character.   *)

  (* 1---------------1 *)

  FUNCTION readxlong(VAR f : text; VAR l : longint) : boolean;
  (* Just like readxint, but for longints.  Always signed. *)

  (* 1---------------1 *)

  FUNCTION readxreal(VAR f : text; VAR r : real) : boolean;
  (* Again, like readxint, but for reals. Also see readreal below *)

  (* 1---------------1 *)

  PROCEDURE readreal(VAR f : text; VAR r : real);
  (* Replacement for the standard read(f, r : real), which aborts *)
  (* on bad entries.  As in STD Pascal, the real is terminated by *)
  (* the first character which cannot be a part of the value, and *)
  (* fptr(f) accesses that terminating character.  Note that this *)
  (* can accept an unlimited length string of digits, eg leading  *)
  (* zeroes, and trailing zeroes after the decimal pt, none of    *)
  (* which really affect the value.  Leading blanks and eolns are *)
  (* skipped. Action on real over/underflow depends on the system *)

  (* 1---------------1 *)

  FUNCTION blockdev(VAR f : text) : boolean;
  (* Is the file attached to a disk file *)

  (* 1---------------1 *)

  FUNCTION stdin(VAR f : text) : boolean;
  (* Is the file attached to the console device for input *)

  (* 1---------------1 *)

  FUNCTION stdout(VAR f : text) : boolean;
  (* is the file attached to the console device for output *)

  (* 1---------------1 *)

  FUNCTION stderr(VAR f : text) : boolean;
  (* is the file attached to the monitor for output *)

IMPLEMENTATION

  CONST        (* really initialized variables *)
    digs       : SET OF char  = ['0'..'9'];
    signs      : SET OF char  = ['+', '-'];
    errornum   : integer      = 0;
    errorat    : pointer      = NIL;
    saverrproc : pointer      = NIL;

    ver                       = 120;
    copyrite                  = ' Copyright (c) 1988 by C.B. Falconer';
    chrdev                    = $80;  (* 0 bit implies file (block) device *)
    istdin                    = $01;
    istdout                   = $02;
    istderr                   = $04;

  (* 1---------------1 *)

  FUNCTION version(show : boolean) : integer;
  (* returns the version number.  Show causes a console message *)

    BEGIN (* version *)
    version := ver;
    IF show THEN BEGIN
      write('TXTFILES module Version ', ver DIV 100 : 1, '.');
      IF ver MOD 100 < 10 THEN write('0');
      writeln(ver MOD 100, '.', copyrite); END;
    END; (* version *)

  (* 1---------------1 *)

  FUNCTION existxt(VAR f : text) : boolean;

    BEGIN (* existxt *)
{$i-}
    reset(f); {$i+}
    existxt := ioresult = 0;
    END; (* existxt *)

  (* 1---------------1 *)

  PROCEDURE filename(VAR f : text; VAR fn : fntype);
  (* Highly Turbo specific *)

    TYPE
      textbuf    = ARRAY[0..127] OF char;

      textrec    = RECORD
        handle     : word;          (* MSDOS file handle *)
        mode       : word;          (* 0=read, 1=write, 2=rdwrt *)
        bufsize    : word;          (* of textbuf *)
        private    : word;
        bufpos     : word;          (* next char pointer *)
        bufend     : word;          (* size of buffer valide *)
        bufptr     : ^textbuf;      (* location, may not be buffer below *)
        openfunc   : pointer;       (* pointers to routines, normally *)
        inoutfunc  : pointer;       (*    in system unit, but may not be *)
        flushfunc  : pointer;
        closefunc  : pointer;

        (* reuse the userdata field for ISO std i/o semantics (plan) *)
        getpends   : boolean;       (* assumed initialized to false *)
        eolnflag   : boolean;       (* so we can have fchar = ' ' *)
        eoflag     : boolean;       (* delay so final get functions *)
        fchar      : char;

        userdata   : ARRAY[5..16] OF byte; (* available *)
        name       : ARRAY[0..79] OF char;
        buffer     : textbuf;
        END; (* textrec *)

    VAR
      i      : integer;

    BEGIN (* filename *)
    fn := ''; i := 0;
    WHILE (i < 79) AND (textrec(f).name[i] <> chr(0)) DO BEGIN
      fn := concat(fn, textrec(f).name[i]); i := succ(i); END;
    END; (* filename *)

  (* 1---------------1 *)

  PROCEDURE page(VAR f : text);   (* Missing in Turbo *)

    BEGIN (* page *)
    write(f, chr(12));
    END; (* page *)

  (* 1---------------1 *)

  PROCEDURE overprint(VAR f : text);
  (* Next line overprints this one *)

    BEGIN (* overprint *)
    write(f, chr(13));
    END; (* overprint *)

  (* 1---------------1 *)

  PROCEDURE prompt(VAR f : text);
  (* forces buffer flushing without eoln *)

    BEGIN (* prompt *)
    END; (* prompt *)

  (* 1---------------1 *)

  PROCEDURE get(VAR f : text);
  (* Together with fptr below, implements the ISO/ANSI semantics  *)

    VAR
      junk     : char;

    BEGIN (* get *)
    read(f, junk);     (* discarding the old value of fptr *)
    END; (* get *)

  (* 1---------------1 *)

  FUNCTION fptr(VAR f : text) : char;
  (* A replacement for the ISO/ANSI Standard Pascal operation f^   *)
  (* With this it is possible to build well behaved input routines *)
  (* to convert text to integers, reals, etc. and avoid crashies   *)
  (* on erroneous user input.  The standard usage of f^ = ' ' at   *)
  (* EOF is not implemented, because of Turbos internal operation. *)

    CONST
      eofmark   = 26;     (* 01ah = CTL-Z *)

    (* 2---------------2 *)

    FUNCTION fptrc(VAR f : text) : char;
    (* For this to function, on a text file, you MUST call eof(f) *)
    (* first, which ensures the char is present in the internal   *)
    (* file buffer.  This procedure extracts it.                  *)

      inline(
        $5f/                   {pop  di;              ^file (off)  }
        $07/                   {pop  es                     (seg)  }
        $26/ $8B/ $5D/ $08/    {mov  bx,es:[di+8];    buffer index }
        $26/ $C4/ $7D/ $0C/    {les  di,es:[di+0ch];  ^buffer      }
        $26/ $8A/ $01);        {mov  al,es:[bx+di];   get char     }

    (* 2---------------2 *)

    BEGIN (* fptr *)
{$i-}
    IF eof(f) {$i+} THEN fptr := chr(eofmark)
    ELSE IF ioresult <> 0 THEN fptr := chr(eofmark)
    ELSE fptr := fptrc(f);
    END; (* fptr *)

  (* 1---------------1 *)

  PROCEDURE skipblks(VAR f : text);

    VAR
      ch    : char;

    BEGIN (* skipblks *)
    ch := fptr(f);
    WHILE (ch = ' ') OR (ch = chr(9)) DO BEGIN
      get(f); ch := fptr(f); END;
    END; (* skipblks *)

  (* 1---------------1 *)

  PROCEDURE skipwhite(VAR f : text);

    BEGIN (* skipwhite *)
    REPEAT             (* caution - Turbo returns eoln at eof *)
      IF eoln(f) AND NOT eof(f) THEN readln(f);
      skipblks(f);
    UNTIL eof(f) OR NOT eoln(f);
    END; (* skipwhite *)

  (* 1---------------1 *)

  FUNCTION readxwd(VAR f : text; VAR w : word) : boolean;

    VAR
      value,
      digit      : word;

    BEGIN (* readxwd *)
    digs := ['0'..'9'];
    readxwd := true; w := 0; value := 0;            (* default error *)
    skipwhite(f);
    IF NOT eof(f) THEN BEGIN
      IF fptr(f) IN digs THEN readxwd := false;       (* found value *)
      WHILE fptr(f) IN digs DO BEGIN
        digit := ord(fptr(f)) - ord('0');
        IF (value < 6553) OR ((value = 6553) AND (digit < 6)) THEN
          value := 10 * value + digit
        ELSE readxwd := true;                            (* overflow *)
        get(f); END;
      w := value; END;
    END; (* readxwd *)

  (* 1---------------1 *)

  FUNCTION readxint(VAR f : text; VAR i : integer) : boolean;

    VAR
      negative   : boolean;
      value      : word;

    BEGIN (* readxint *)
    readxint := true; i := 0; negative := false;    (* default error *)
    skipwhite(f);
    IF NOT eof(f) THEN BEGIN
      value := 0; negative := false;
      IF fptr(f) IN signs THEN BEGIN            (* absorbing any '+' *)
        negative := fptr(f) = '-'; get(f); END;
      IF fptr(f) IN digs THEN                         (* found value *)
        readxint := readxwd(f, value);
      IF negative AND (value <= 32768) THEN i := -value
      ELSE IF value <= 32767 THEN i := value
      ELSE readxint := true; END;                        (* overflow *)
    END; (* readxint *)

  (* 1---------------1 *)

  FUNCTION callersaddr : pointer;
  (* relies on the fact that bp always points to the return addr *)
  (* and that this is a FAR return, i.e. via an entry to a unit. *)

    inline(
      $C4/ $46/ $02/   {les ax,[bp+2]                   }
      $8C/ $C2);       {mov dx,es;  now dx:ax is address}

  (* 1---------------1 *)

  PROCEDURE readint(VAR f : text; VAR i : integer);

    BEGIN (* readint *)
    IF readxint(f, i) THEN BEGIN     (* invalid numeric format error *)
      errorat := callersaddr; errornum := 106;
      halt(errornum); END;
    END; (* readint *)

  (* 1---------------1 *)

  PROCEDURE readwd(VAR f : text; VAR w : word);

    BEGIN (* readwd *)
    IF readxwd(f, w) THEN BEGIN (* invalid numeric format error *)
      errorat := callersaddr; errornum := 106;
      halt(errornum); END;
    END; (* readwd *)

  (* 1---------------1 *)

  FUNCTION readxlong(VAR f : text; VAR l : longint) : boolean;

    CONST
      threshold  = 214748363;

    VAR
      negative   : boolean;
      digit      : integer;
      value      : longint;

    BEGIN (* readxlong *)
    readxlong := true; l := 0; negative := false;   (* default error *)
    skipwhite(f);
    IF NOT eof(f) THEN BEGIN
      value := 0; negative := false;
      IF fptr(f) IN signs THEN BEGIN            (* absorbing any '+' *)
        negative := fptr(f) = '-'; get(f); END;
      IF fptr(f) IN digs THEN BEGIN                   (* found value *)
        readxlong := false;              (* no error unless overflow *)
        WHILE fptr(f) IN digs DO BEGIN
          digit := ord(fptr(f)) - ord('0');
          IF value <= threshold THEN value := value * 10 + digit
          ELSE readxlong := true;                        (* overflow *)
          get(f); END;
        IF negative THEN l := -value
        ELSE l := value; END;
      END;
    END; (* readxlong *)

  (* 1---------------1 *)

  FUNCTION readxreal(VAR f : text; VAR r : real) : boolean;
  (* true for error *)

    LABEL 10;          (* error exit *)

    VAR
      maxsig,
      significand    : longint;
      exponent       : integer;
      decpt          : integer;
      havedigit,
      minus          : boolean;

    BEGIN (* readxreal *)
    minus := false; r := 0.0; readxreal := true; havedigit := false;
    significand := 0; decpt := 0; exponent := 0;        (* defaults *)
    maxsig := $7ffffff5 DIV 10;       (* before nextch can overflow *)
    skipwhite(f);
    IF fptr(f) IN signs THEN BEGIN
      minus := fptr(f) = '-'; get(f); END;
    IF fptr(f) IN digs + ['.'] THEN BEGIN
      readxreal := false;          (* should be able to get a value *)
      WHILE (fptr(f) IN digs) AND (significand < maxsig) DO BEGIN
        significand := significand * 10 + (ord(fptr(f)) - ord('0'));
        havedigit := true; get(f); END;
      WHILE fptr(f) IN digs DO BEGIN         (* gobble non-significants *)
        decpt := succ(decpt); get(f); END;
      IF fptr(f) = '.' THEN BEGIN
        get(f);
        IF NOT (havedigit OR (fptr(f) IN digs)) THEN BEGIN
          readxreal := true; GOTO 10; END
        ELSE BEGIN
          WHILE (fptr(f) IN digs) AND (significand < maxsig) DO BEGIN
            significand := significand * 10 + (ord(fptr(f)) - ord('0'));
            decpt := pred(decpt); get(f); END;
          WHILE fptr(f) IN digs DO get(f); END; (* eat non-significants *)
        END;

      (* now have to worry about E+-nn appended *)
      IF fptr(f) IN ['E', 'e'] THEN BEGIN
        get(f);
        IF NOT (fptr(f) IN digs + signs) THEN BEGIN
          readxreal := true; GOTO 10; END
        ELSE IF readxint(f, exponent) THEN BEGIN
          readxreal := true; GOTO 10; END;
        END;

      (* Now we have valid significand, decpt, exponent *)
      exponent := exponent + decpt;
      r := significand;
      WHILE exponent > 0 DO BEGIN
        r := 10.0 * r; exponent := pred(exponent); END;
      WHILE exponent < 0 DO BEGIN
        r := r / 10.0; exponent := succ(exponent); END;
      IF minus THEN r := -r; END;
10: END; (* readxreal *)

  (* 1---------------1 *)

  PROCEDURE readreal(VAR f : text; VAR r : real);

    BEGIN (* readreal *)
    IF readxreal(f, r) THEN BEGIN  (* invalid numeric format error *)
      errorat := callersaddr; errornum := 106;
      halt(errornum); END;
    END; (* readreal *)

  (* 1---------------1 *)
{$F+}
  PROCEDURE txterrproc;      (* MUST be a FAR procedure *)

    VAR
      errorptr  : RECORD
        offset    : integer;
        segment   : integer;
        END                    ABSOLUTE errorat;

    BEGIN (* txterrproc *)
    exitproc := saverrproc;
    IF errornum <> 0 THEN BEGIN
      exitcode := errornum;
      writeln('Invalid numerical entry or overflow ');
      errorptr.segment := errorptr.segment - prefixseg - 16;
      erroraddr := errorat; END;
    END; (* txterrproc *)

  (* 1---------------1 *)

  FUNCTION qfstatus(VAR f; VAR s : integer) : boolean;
  (* returns false if file not open or open for random access *)

    VAR
      ff     : text ABSOLUTE f;
      regs   : registers;

    BEGIN (* qfstatus *)
    qfstatus := false;            (* default *)
    WITH regs, textrec(ff) DO
      IF (mode = fminput) OR (mode = fmoutput) OR (mode = fminout) THEN BEGIN
        ax := $4400; bx := handle;
        msdos(regs);                     (* get device info *)
        IF (flags AND fcarry) = 0 THEN BEGIN
          qfstatus := true; s := integer(dx); END;
        END;
    END; (* qfstatus *)

  (* 1---------------1 *)

  FUNCTION blockdev(VAR f : text) : boolean;
  (* Is the file attached to a disk file *)

    VAR
      fstatus  : integer;

    BEGIN (* blockdev *)
    IF qfstatus(f, fstatus) THEN
      blockdev := ((fstatus AND chrdev = 0))
    ELSE blockdev := false;
    END; (* blockdev *)

  (* 1---------------1 *)

  FUNCTION stdin(VAR f : text) : boolean;
  (* Is the file attached to the console device *)

    VAR
      fstatus  : integer;

    BEGIN (* stdin *)
    IF qfstatus(f, fstatus) THEN
      stdin := ((fstatus AND chrdev <> 0)) AND
               ((fstatus AND istdin) <> 0)
    ELSE stdin := false;
    END; (* stdin *)

  (* 1---------------1 *)

  FUNCTION stdout(VAR f : text) : boolean;

    VAR
      fstatus  : integer;

    BEGIN (* stdout *)
    IF qfstatus(f, fstatus) THEN
      stdout := ((fstatus AND chrdev <> 0)) AND
                ((fstatus AND istdout) <> 0)
    ELSE stdout := false;
    END; (* stdout *)

  (* 1---------------1 *)

  FUNCTION stderr(VAR f : text) : boolean;

    VAR
      fstatus  : integer;

    BEGIN (* stderr *)
    IF qfstatus(f, fstatus) THEN
      stderr := ((fstatus AND chrdev <> 0)) AND
                ((fstatus AND istderr) <> 0)
    ELSE stderr := false;
    END; (* stderr *)

  (* 1---------------1 *)

  BEGIN (* txtfiles initialization routine *)
  saverrproc := exitproc; exitproc := addr(txterrproc);
  IF version(false) <> ver THEN halt;
  END. (* txtfiles *)
╝